COMMENT ⊗   VALID 00006 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00003 00003	!	define reserved token codes 
C00011 00004	!	tables to set up reserved words 
C00014 00005	! 	decoding a token to give its various parameters 
C00016 00006	!	procedure parse itself
C00019 ENDMK
C⊗;
ENTRY;
BEGIN "PARSE"
DEFINE $$PRGID=TRUE;	DEFINE $PARSE=TRUE;	
REQUIRE "HEADER.SAI" SOURCE_FILE;
!	define reserved token codes ;

!	format is as follows:
	ZZ(symbol, opcode number, precedence level)	for operators
	XX(flag,  statement reserved word,  parsing procedure to call)
				where flag indicates whether this statement
				is available in the current version
	XXZZ(flag, symbol, parsing procedure, opcode number, precedence level)
				for symbols which are both operators and
				first words of statements ;
define tokencodes "[][]" =[
ZZ("↓",		DOWNARROW_X,	PF_XX)
ZZ("∧",		and_X,		BFACT_XX)
ZZ("¬",		not_X,		PF_XX)
ZZ("⊗",		xor_X,		BEFACT_XX)
ZZ("→",		frontarrow_X,	FACTOR_XX)
ZZ("≠",		sne_X,		BTERM_XX)
ZZ("≤",		sle_X,		BTERM_XX)
ZZ("≥",		sge_X,		BTERM_XX)
ZZ("≡",		eqv_X,		EXP_XX)
ZZ("∨",		or_X,		BEFACT_XX)
ZZ("$",		DOLLAR_X,	PF_XX)
ZZ("α",		ALPHA_X,	PF_XX)
ZZ(["("],	LPAREN_X,	PF_XX)
ZZ("*",		times_X,	TERM_XX)
ZZ("+",		Plus_X,		AEXP_XX)
ZZ("-",		minus_X,	AEXP_XX)
ZZ(".",		vdot_X,		TERM_XX)
ZZ("/",		sdiv_X,		TERM_XX)
ZZ("<",		slt_X,		BTERM_XX)
ZZ("=",		seq_X,		BTERM_XX)
ZZ(">",		sgt_X,		BTERM_XX)
XX(TRUE,	ABORT,		ABORTPROC)
ZZ("ACOS",	acos_X,		PF_XX)
XX(TRUE,	AFFIX,		AFFIXPROC)
XX(TRUE,	ALL,		NOTAVAILCALL)
ZZ("AND",	aand_X,		BFACT_XX)
XX(TRUE,	ARRAY,		NOTAVAILCALL)
ZZ("ASIN",	asin_X,		PF_XX)
ZZ("ATAN2",	atan2_X,	PF_XX)
ZZ("AXIS",	axis_X,		PF_XX)
XX(TRUE,	BAIL,		BAILCALL)
XX(TRUE,	BEGIN,		BEGINPROC)
XX(#MOVE,	BY,		DEFLT("BY"))
XX(TRUE,	CASE,		CASEPROC)
XX(#MOVE,	CENTER,		CENTERPROC)
XX(TRUE,	CLOSE,		CLOSEPROC)
XX(TRUE,	COBEGIN,	COBEGINPROC)
XX(TRUE,	COEND,		ENDPROC("COEND"))
XX(TRUE,	COMMENT,	[READTO(";")])
ZZ("CONSTRUCT",	construct_X,	PF_XX)
ZZ("COS",	cos_X,		PF_XX)
XX(TRUE,	DDT,		DDTPROC)
XX(TRUE,	DEFINE,		DEFINECALL)
XX(TRUE,	DELETE,		DELETECALL)
XX(#DISPL,	DISPLAY,	DISPLAYCALL)
ZZ("DIV",	div_X,		TERM_XX)
XX(TRUE,	DO,		DOPROC)
XX(#MOVE,	DRIVE,		DRIVEPROC)
XX(TRUE,	ECHOOFF,	[FILEPRINT←FALSE])
XX(TRUE,	ECHOON,		[FILEPRINT←TRUE])
XX(TRUE,	EDIT,		EDITCALL)
XX(TRUE,	EEDIT,		EEDITCALL)
XX(TRUE,	END,		ENDPROC)
ZZ("EQV",	eeqv_X,		EXP_XX)
ZZ("EVAL",	EVAL_X,		PF_XX)
XX(TRUE,	EXIT,		EXITCALL)
ZZ("EXP",	exp_X,		PF_XX)
XX(FALSE,	FCONSTRUCT,	FCONSTRUCTPROC)
XX(TRUE,	FOR,		FORPROC)
XXZZ(TRUE,	FRAME,	DECLPROC(#FR),	FRAME_X,	PF_XX)
XX(not #nofunct,	FUNCTION,	FUNCTPROC)
XX(#GATHER,	GATHER,		GATHERPROC)
XX(#GATHER,	GRAPH,		GRAPHCALL)
XX(TRUE,	HELP,		NOTAVAILCALL)
XX(TRUE,	IF,		IFPROC)
ZZ("INT",	int_X,		PF_XX)
XX(TRUE,	INTO,		NOTAVAILCALL)
ZZ("INV",	rinv_X,		PF_XX)
ZZ("LOG",	log_X,		PF_XX)
ZZ("MAX",	max_X,		TERM_XX)
ZZ("MIN",	min_X,		TERM_XX)
ZZ("MOD",	mod_X,		TERM_XX)
XX(#MOVE,	MOVE,		MOVEPROC)
XX(#MOVE,	MOVEX,		AXMOVPROC)
XX(#MOVE,	MOVEY,		AXMOVPROC)
XX(#MOVE,	MOVEZ,		AXMOVPROC)
XX(#DISPL,	NODISPLAY,	NODISPLAYCALL)
XX(#DISPL,	NOUPDATE,	[$ALLOW←$ALLOW+1])
XX(TRUE,	ON,		ONPROC)
XX(#MOVE,	OPEN,		OPCLPROC(TOKEN))
ZZ("OR",	oor_X,		BEFACT_XX)
XXZZ(TRUE,	ORIENT,	COORDPROC(0,#RT),	ORIENT_X,	PF_XX)
XX(#MOVE,	PARK,		PARKINGPROC)
XX(TRUE,	PHOTO,		PHOTOCALL)
XXZZ(TRUE,	POS,	COORDPROC(0,#VT),	POS_X,	PF_XX)
XX(TRUE,	PRINT,		PRINTPROC)
XX(TRUE,	PROCEDURE,	PROCDECLPROC)
XX(TRUE,	PROMPT,		PROMPTPROC)
XX(TRUE,	QBAIL,		QBLCALL)
XX(TRUE,	QDELETE,	DELETECALL(TRUE))
XX(#OUTPT,	QREAD,		READCALL(FALSE))
XX(#OUTPT,	READ,		READCALL)
XX(TRUE,	READMESSAGE,	READMESSCALL)
XX(#WRIST,	READWRIST,	READWRISTPROC)
XX(TRUE,	REDEFINE,	DEFINECALL(TRUE))
XX(#DISPL,	REDISPLAY,	REDISPLAYCALL)
XX(TRUE,	REFERENCE,	NOTAVAILCALL)
ZZ("REL",	rel_X,		FACTOR_XX)
XX(TRUE,	RENAME,		RENAMCALL)
XX(TRUE,	RESETSTATUS,	SETSTATUSCALL(0))
XX(TRUE,	RETURN,		RETURNPROC)
! ZZ("ROT",	ROT_X,		PF_XX) ;
XXZZ(TRUE,	ROT,		DECLPROC(#RT),	ROT_X,	PF_XX)
XX(TRUE,	SCALAR,		DECLPROC(#SC))
XX(TRUE,	SETBASE,	SETBASEPROC)
XX(TRUE,	SETSTATUS,	SETSTATUSCALL(1))
XX(TRUE,	SETSTIFF,	SETSTIFFPROC)
XX(TRUE,	SHOW,		SHOWCALL)
ZZ("SIN",	sin_X,		PF_XX)
ZZ("SQRT",	sqrt_X,		PF_XX)
XX(TRUE,	STOP,		STOPPROC)
XX(TRUE,	STOPMESSAGE,	STOPMESSCALL)
XX(TRUE,	SUBTREE,	NOTAVAILCALL)
ZZ("TAN",	tan_X,		PF_XX)
XX(#MOVE,	TO,		DEFLT("TO"))
XXZZ(TRUE,	TRANS,		DECLPROC(#TR),	TRANS_X,	PF_XX)
XX(TRUE,	UNFIX,		UNFIXPROC)
ZZ("UNIT",	uvect_X,	PF_XX)
XX(#DISPL,	UPDATE,		[$ALLOW←$ALLOW-1])
XX(TRUE,	VALUE,		NOTAVAILCALL)
XXZZ(TRUE,	VECTOR,	DECLPROC(#VT),	VECTOR_X,	PF_XX)
XX(TRUE,	VT05_OFF,	VT05PROC(1))
XX(TRUE,	VT05_ON,	VT05PROC(0))
XX(TRUE,	WHILE,		WHILEPROC)
XX(TRUE,	WRIST,		WRISTPROC)
XX(#OUTPT,	WRITE,		WRITCALL)
ZZ("WRT",	wrt_X,		FACTOR_XX)
XXZZ(TRUE,	XCOORD,	COORDPROC(1,#SC),	COORDX_X,	PF_XX)
ZZ("XOR",	xxor_X,		BEFACT_XX)
XXZZ(TRUE,	YCOORD,	COORDPROC(2,#SC),	COORDY_X,	PF_XX)
XXZZ(TRUE,	ZCOORD,	COORDPROC(3,#SC),	COORDZ_X,	PF_XX)
ZZ("↑",		stos_X,		FACTOR_XX)
ZZ("|",		MAGNITUDE_X,	PF_XX)
];

!	tables to set up reserved words ;

	! count number of reserved tokens ;
define res_count = 0;
redefine zz(symb,opnum,precedence_level)"[][]"=[redefine res_count=res_count+1;];
redefine xxzz(#flag,str,parsing_proc,opnum,precedence_level)"[][]"
		=[redefine res_count=res_count+1;];
redefine xx(#flag, str, parsing_proc)"[][]"=[redefine res_count=res_count+1;];

	! **************************************** ;
	! *****;	tokencodes;	! ******** ;
	! at this point res_count contains actual # of reserved words ;


	! set up a string array of reserved tokens  in RESCODE ;
redefine xx(#flag, str, parsing_proc)"[][]"=["str", ];
redefine xxzz(#flag,str,parsing_proc,opnum,precedence_level)"[][]"=["str",];
redefine zz(symb,opnum,precedence_level)"[][]"=[symb,];

preload_array( rescode , tokencodes , string , 1 , res_count);

	! set up an integer array of codes  for the reserved tokens ;
define xx_count=0;
redefine xx(#flag, str, parsing_proc)"[][]"=[
	redefine xx_count=xx_count+1; 
	xx_count*(#OPERATORS+1)*#DTYPE, ];
redefine zz(symb,opnum,precedence_level)=
	[opnum*#DTYPE+precedence_level,];
redefine xxzz(#flag,str,parsing_proc,opnum,precedence_level)"[][]"=[
	redefine xx_count=xx_count+1;
	(xx_count*(#OPERATORS+1)+opnum)*#DTYPE+precedence_level, ];

	! ***** now set up the array as TCODES  ***** ;
preload_array(tcodes, tokencodes, integer, 1, res_count);

! 	decoding a token to give its various parameters ;
!	res_class = class of reserved word, 0 if strict operator
	token_class = operator class
	token_index = precedence level ;

INTERNAL INTEGER PROCEDURE DECSTR(string VAL);
	BEGIN INTEGER L,M,U,I1,I2; STRING S1,S2;
	L←1; U←res_count;
	DO begin M←(U+L)/2;
	    CASE COMPEQU(rescode[M],VAL)+1 OF
		BEGIN
		[-1+1]	U←M-1;
		[0+1]	begin res_class←TCODES[M] DIV( (#OPERATORS+1)*#DTYPE);
				tokenclass←tcodeS[m] mod #dtype;
				tokenindex← (tcodeS[m] div #dtype) mod (#OPERATORS+1);
				RETURN(M);
			end;
		[1+1]	L←M+1
		END;
	   end UNTIL L>U;
	res_class←tokenclass←tokenindex←0;
	RETURN(0);
	END;

!	procedure parse itself;

INTERNAL RECURSIVE RPTR(EXPR$)PROCEDURE PARSE;
BEGIN "PARSER"
	$$PCODE←NULL_RECORD;		! initialize at beginning of statement;
	NOEXPAND←FALSE;			! enable macro expansions ;
	GTOKEN;				! reads first token;
	STBEGIN←FALSE;			! acknowledge that no longer beginning
					  of statement;
	IF "A"≤ TOKEN ≤"Z" THEN
	   CASE res_class of
   	        BEGIN "CASE"
		redefine xx(#flag, str,oper)"[][]"=[
			ifc #flag thenc ; oper elsec ; notavailcall endc];
		redefine xxzz(#flag, str,oper,arg1,arg2)"[][]"=[
			 ; oper ];
		redefine zz(arg1,arg2,arg3)"[][]"=[];
		ASSIGNPROC
		tokencodes
	        END "CASE"
ELSE IF TOKEN=";" OR TOKEN=NULL THEN
		BEGIN IF $COMPILE THEN STOKEN←TRUE END
ELSE IF TOKEN="?" THEN PRINT(#VERSION)
ELSE	IFC #ARROW THENC
	IF TOKEN="↑" 
	   THEN BEGIN $ARROW←$ARROW+20; UPDATE; END
	ELSE IF TOKEN="↓" 
	   THEN BEGIN $ARROW←$ARROW-20; UPDATE; END
	ELSE IF #TOKEN=INT_TYPE
	   THEN BEGIN
		INTEGER NUM;
		NUM←INTSCAN(TOKEN,$BRCHR);
		GTOKEN;
		IF TOKEN="↓" THEN $ARROW←$ARROW-NUM*20
		   ELSE IF TOKEN="↑" THEN $ARROW←$ARROW+NUM*20
		   ELSE	ERROR("unrecognized instruction");
		UPDATE;
		END
           ELSE ENDC 
		BEGIN ERROR("wrong identifier or wrong number"); END;

	IF NOT $COMPILE
	   THEN BEGIN "interpret it"
		$ALLOW←$ALLOW+1;
		IF $$PCODE THEN $EXECUTE($$PCODE);
		$$PCODE←NULL_RECORD;
		$ALLOW←$ALLOW-1;
		IFC #DISPL THENC UPDATE; ENDC
		END;
	RETURN($$PCODE);
END "PARSER";


END "PARSE";